home *** CD-ROM | disk | FTP | other *** search
/ Trading on the Edge / Trading On The Edge - CD-ROM Toolkit (Wayzata Technology)(2031)(1994).bin / pc / mac_file / vendor_d / ga_softw / ooga / evaluate.lis < prev    next >
Lisp/Scheme  |  1991-02-03  |  12KB  |  409 lines
  1. ;;; -*- Mode:Lisp; Package:OOGA; Base:10; Syntax:COMMON-LISP -*-
  2. #||
  3.             RESTRICTED RIGHTS LEGEND
  4.                     
  5.  Use, duplication, or disclosure by the Government is subject to
  6.  restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
  7.  Technical Data and Computer Software Clause at 52.227-7013 of the DOD
  8.  FAR Supplement.
  9.                     
  10.                 TSP (The Software Partnership)
  11.                 P.O. Box 991
  12.                 Melrose, MA 02176
  13.                     
  14.       Copyright 1990 by Lawrence Davis and Daniel Cerys, all rights reserved.
  15. ||#
  16.  
  17. (in-package :ooga)
  18.  
  19.  
  20. ;************************************************************
  21.  
  22. ;    PROBLEM 1:  F6 (THE SINE ENVELOPE SIN WAVE)
  23.  
  24.  
  25.  
  26. (defun F6 (x1 x2)
  27.   "Inverted F6 from Shaffer et al's test suite -- the sine envelope sin wave"
  28.   (let* ((sum-of-squares (+ (* x1 x1) (* x2 x2)))
  29.      (numerator-sin (sin (sqrt sum-of-squares)))
  30.      (denominator-amount (+ 1.0 (* .001 sum-of-squares))))
  31.     (+ 0.5
  32.        (/ (- (* numerator-sin numerator-sin) 0.5)
  33.       (* denominator-amount denominator-amount)))))
  34.  
  35.  
  36. ;;; F6 in binary
  37.  
  38. (defclass BINARY-F6
  39.       (evaluator)
  40.   ())
  41.  
  42.  
  43. (defmethod EVALUATE-MEMBER ((evaluator binary-f6) population-member)
  44.     (let* ((raw-x1 (coerce (convert-bit-string-to-integer
  45.                  (firstn 22 (chromosome population-member)))
  46.            'double-float))
  47.        (raw-x2 (coerce (convert-bit-string-to-integer
  48.              (nthcdr 22 (chromosome population-member)))
  49.            'double-float))
  50.        (x1 (- (* raw-x1 4.768372718899898d-5) 100))
  51.        (x2 (- (* raw-x2 4.768372718899898d-5) 100)))
  52.       (- 1.0 (f6 x1 x2))))
  53.  
  54.  
  55. ;;; F6 in binary with values increased by 999.
  56.  
  57. (defclass ELEVATED-BINARY-F6
  58.       (evaluator)
  59.   ())
  60.  
  61.  
  62. (defmethod EVALUATE-MEMBER ((evaluator elevated-binary-f6) population-member)
  63.     (let* ((raw-x1 (coerce (convert-bit-string-to-integer
  64.                  (firstn 22 (chromosome population-member)))
  65.            'double-float))
  66.        (raw-x2 (coerce (convert-bit-string-to-integer
  67.              (nthcdr 22 (chromosome population-member)))
  68.            'double-float))
  69.        (x1 (- (* raw-x1 4.768372718899898d-5) 100))
  70.        (x2 (- (* raw-x2 4.768372718899898d-5) 100)))
  71.       (- 1000.0 (f6 x1 x2))))
  72.  
  73.  
  74.  
  75. ;;; F6 with real numbers.
  76.  
  77. (defclass REAL-NUMBER-F6
  78.       (evaluator)
  79.   ())
  80.  
  81.  
  82. (defmethod EVALUATE-MEMBER ((evaluator real-number-f6) population-member)
  83.     (let* ((x1 (- (* (car (chromosome population-member))
  84.              4.768372718899898d-5) 100))
  85.        (x2 (- (* (cadr (chromosome population-member))
  86.              4.768372718899898d-5) 100)))
  87.       (- 1.0 (f6 x1 x2))))
  88.  
  89.  
  90. ;**************************************************
  91. ;**************************************************
  92.  
  93.  
  94. ;    NODE COLORING PROBLEM
  95.  
  96.  
  97.  
  98. ;**************************************************
  99.  
  100. ;    GRAPH ROUTINES
  101.  
  102.  
  103.  
  104. ;**************************************************
  105.  
  106. ;    BASIC CLASS DEFINITIONS
  107.  
  108.  
  109. ;A GRAPH contains a list of nodes and a list of edges.
  110. ;The nodes are of class node-class.  The edges are not
  111. ;explicitly represented.
  112.  
  113. (defclass GRAPH
  114.       ()
  115.      ((NODES :initarg :nodes :initform nil :accessor nodes)))
  116.  
  117.  
  118. ;Vanilla NODE class.  There is an index (could be a name),
  119. ;a list of neighbors, and a list of attached edges.
  120.  
  121. (defclass NODE
  122.       ()
  123.      ((index :initarg :index :reader index)
  124.       (neighbors :initform nil :initarg :neighbors :accessor neighbors)))
  125.  
  126.  
  127. ;**************************************************
  128.  
  129. ;    GRAPH COLORING NODE
  130.  
  131.  
  132. ;Vanilla node with weight.  Default is 1.
  133. (defclass GRAPH-COLORING-NODE
  134.       (node)
  135.      ((WEIGHT :initform 1 :initarg :weight :reader weight)
  136.       (COLOR :initarg :color :initform nil :accessor color)))
  137.  
  138.  
  139. ;**************************************************
  140.  
  141. ;    RANDOM GRAPH CREATION ROUTINES
  142.  
  143.  
  144. ;    GRAPH SPECS
  145.  
  146.  
  147. (defun MAKE-GRAPH-SPECS (node-number edge-number)
  148.   "Randomly create graph specs."
  149.   (let* ((node-specs (loop for n from 1 to node-number
  150.                   collect (list n (+ 60 (random 200)))))
  151.      (edge-specs (make-edge-specs node-number edge-number)))
  152.     (loop for node-spec in node-specs
  153.       for edge-spec in edge-specs
  154.       collect (append node-spec
  155.               (list (sort (get-connected-nodes
  156.                     (car node-spec) edge-specs)
  157.                       (function (lambda (x y) (< x y)))
  158.                       ))))))
  159.  
  160.  
  161. (defun MAKE-EDGE-SPECS (node-number edge-number)
  162.   "Create edge specs."
  163.   (loop with node-indices = (loop for x from 1 to node-number collect x)
  164.     with edges = nil
  165.     for index1 = (random-member node-indices)
  166.     for index2 = (random-member node-indices)
  167.     for new-edge = (if (> index1 index2)
  168.                (list index2 index1)
  169.                (list index1 index2))
  170.     until (>= (length edges) edge-number)
  171.     do (unless (or (= index1 index2)
  172.                (loop for edge in edges
  173.                  thereis (equal edge new-edge)))
  174.          (setf edges (cons new-edge edges)))
  175.     finally (return edges)))
  176.  
  177.  
  178.  
  179. (defun GET-CONNECTED-NODES (node-index edge-specs)
  180.   "Find the nodes connected to the node with the given index."
  181.   (loop for spec in edge-specs
  182.     when (member node-index spec)
  183.     collect (other-index node-index spec) into neighbors
  184.     finally (return neighbors)))
  185.  
  186.  
  187. (defun OTHER-INDEX (index spec)
  188.   "Get the index of the other node in the spec"
  189.   (if (= index (car spec)) (cadr spec) (car spec)))
  190.  
  191.  
  192. (defmethod MAKE-AND-LINK-NODES (node-specs)
  193.   "Make the nodes from the specs"
  194.   (let ((nodes (loop for spec in node-specs
  195.              collect (make-instance 'graph-coloring-node
  196.                         :index (car spec)
  197.                         :weight (cadr spec)))))
  198.     (loop for node in nodes
  199.       for neighbor-indices = (third (assoc (index node) node-specs))
  200.       do (setf (neighbors node) (get-nodes-with-indices nodes neighbor-indices)))
  201.     nodes))
  202.  
  203.  
  204. (defun GET-NODES-WITH-INDICES (nodes indices)
  205.   "Find the nodes with the given indices"
  206.   (loop for index in indices
  207.     collect (loop for node in nodes
  208.               when (= (index node) index)
  209.               do (return node)
  210.               finally (format *standard-output* "~%No Node With Index ~a" index))))
  211.  
  212.  
  213. (defun MAKE-GRAPH-FROM-SPECS (node-specs)
  214.   "Make the graph from the specs"
  215.   (let ((graph (make-instance 'graph)))
  216.     (setf (nodes graph) (make-and-link-nodes node-specs))
  217.     graph))
  218.  
  219.  
  220. ;**************************************************
  221.  
  222. ;    SPECS FOR 100-NODE GRAPH
  223.  
  224. ;; Best solution found = 10413 
  225. ;; with a 320/4000 version of GA 6-1.
  226.  
  227.  
  228. (defvar *GRAPH-SPECS*
  229.     '(
  230.    (1 62 (20 58 74 82)) 
  231.    (2 183 (6 12 20 28 29 32 51 53 56 70 79 84 94)) 
  232.    (3 247 (18 24 33 50 88 92)) 
  233.    (4 66 (70 74 75 79 95 98)) 
  234.    (5 181 (7 25 32 34 44 55 69 85)) 
  235.    (6 95 (2 62 67 84 91)) 
  236.    (7 112 (5 43 47 82 84)) 
  237.    (8 65 (10 20 25 71 72 91)) 
  238.    (9 163 (32 44 46 62 67 69 71 82 92)) 
  239.    (10 112 (8 34 40 43 76 83 88 93)) 
  240.    (11 153 (12 18 23 26 30 73 82 97)) 
  241.    (12 117 (2 11 16 17 25 31 36 44 69 71 72 80 84)) 
  242.    (13 163 (28 29 38 61 67 77 92)) 
  243.    (14 239 (25 33 61 92)) 
  244.    (15 193 (19 25 38 56 57 67 88 96 100)) 
  245.    (16 241 (12 25 40 42 64 68)) 
  246.    (17 255 (12 23 30 39 79 82)) 
  247.    (18 153 (3 11 36 58 59 73 80 90 96)) 
  248.    (19 191 (15 31 35 47 49)) 
  249.    (20 209 (1 2 8 31 61 73 100)) 
  250.    (21 97 (22 27 28 32 88 93)) 
  251.    (22 133 (21 52 63 71 82 89 94 100)) 
  252.    (23 84 (11 17 25 37 49 62 71 84 90 93)) 
  253.    (24 103 (3 26 43 55 56 58 66 72 98)) 
  254.    (25 81 (5 8 12 14 15 16 23 36 61 63 75 87)) 
  255.    (26 104 (11 24 37 41 46 53 64 68 94)) 
  256.    (27 220 (21 29 32 40 53 65 74 78)) 
  257.    (28 208 (2 13 21 42 68 72 79 87)) 
  258.    (29 187 (2 13 27 40 43 60 64 71 99 100)) 
  259.    (30 129 (11 17 52 54 60 67)) 
  260.    (31 65 (12 19 20 39 42 56 71 78 83 89 90 93)) 
  261.    (32 181 (2 5 9 21 27 35 37 38 49 50 68 73 79)) 
  262.    (33 141 (3 14 35 36 40 49 62 76)) 
  263.    (34 118 (5 10 36 41 55 87 100)) 
  264.    (35 81 (19 32 33 38 40 44 55 77)) 
  265.    (36 70 (12 18 25 33 34 46 50 53 70 78 81 91)) 
  266.    (37 210 (23 26 32 60 88 97)) 
  267.    (38 95 (13 15 32 35 50 60 61 78 88)) 
  268.    (39 103 (17 31 64 77)) 
  269.    (40 187 (10 16 27 29 33 35 51 53 82 86)) 
  270.    (41 121 (26 34 81 96)) 
  271.    (42 97 (16 28 31 51 56 75 76 78 87 94)) 
  272.    (43 130 (7 10 24 29 70)) 
  273.    (44 113 (5 9 12 35 70 74 81 91 100)) 
  274.    (45 169 (53 78 81 86)) 
  275.    (46 182 (9 26 36 50 54 59 63 83 92 96 98)) 
  276.    (47 232 (7 19 64 77 84 92)) 
  277.    (48 233 (49 84 88)) 
  278.    (49 250 (19 23 32 33 48 59 60 68 77 83 89 91)) 
  279.    (50 220 (3 32 36 38 46 55 57 84 86 87 97)) 
  280.    (51 117 (2 40 42 57 69 98)) 
  281.    (52 126 (22 30 61 81 84 99)) 
  282.    (53 84 (2 26 27 36 40 45 54 55 93 97 99)) 
  283.    (54 182 (30 46 53 57 58 69 95)) 
  284.    (55 145 (5 24 34 35 50 53 79 87)) 
  285.    (56 176 (2 15 24 31 42 67 71 89 92)) 
  286.    (57 241 (15 50 51 54 62 65)) 
  287.    (58 178 (1 18 24 54 59 67 79 88)) 
  288.    (59 226 (18 46 49 58 64 82)) 
  289.    (60 242 (29 30 37 38 49 62 82 90 91 100)) 
  290.    (61 153 (13 14 20 25 38 52 70 77 86)) 
  291.    (62 79 (6 9 23 33 57 60 63 77 88)) 
  292.    (63 236 (22 25 46 62 68 72 85 94 98)) 
  293.    (64 106 (16 26 29 39 47 59 76 85 96)) 
  294.    (65 218 (27 57 82 96)) 
  295.    (66 205 (24 67 84 96 97)) 
  296.    (67 154 (6 9 13 15 30 56 58 66 76 99)) 
  297.    (68 221 (16 26 28 32 49 63 69 79)) 
  298.    (69 164 (5 9 12 51 54 68 79 89)) 
  299.    (70 104 (2 4 36 43 44 61 77)) 
  300.    (71 105 (8 9 12 22 23 29 31 56 88 95)) 
  301.    (72 212 (8 12 24 28 63 86 87 97)) 
  302.    (73 218 (11 18 20 32 84 85 93 97)) 
  303.    (74 90 (1 4 27 44 77 88 92 95)) 
  304.    (75 193 (4 25 42 81 99)) 
  305.    (76 242 (10 33 42 64 67 78 85 86)) 
  306.    (77 236 (13 35 39 47 49 61 62 70 74 80 93 95)) 
  307.    (78 86 (27 31 36 38 42 45 76 93)) 
  308.    (79 118 (2 4 17 28 32 55 58 68 69 96)) 
  309.    (80 72 (12 18 77 94 99)) 
  310.    (81 234 (36 41 44 45 52 75 97)) 
  311.    (82 125 (1 7 9 11 17 22 40 59 60 65 88 94 98)) 
  312.    (83 90 (10 31 46 49)) 
  313.    (84 153 (2 6 7 12 23 47 48 50 52 66 73 93 95 99)) 
  314.    (85 199 (5 63 64 73 76 88)) 
  315.    (86 154 (40 45 50 61 72 76 87 89 91 93)) 
  316.    (87 107 (25 28 34 42 50 55 72 86 100)) 
  317.    (88 79 (3 10 15 21 37 38 48 58 62 71 74 82 85)) 
  318.    (89 75 (22 31 49 56 69 86 96 99)) 
  319.    (90 76 (18 23 31 60)) 
  320.    (91 229 (6 8 36 44 49 60 86)) 
  321.    (92 182 (3 9 13 14 46 47 56 74)) 
  322.    (93 251 (10 21 23 31 53 73 77 78 84 86 97)) 
  323.    (94 250 (2 22 26 42 63 80 82 97)) 
  324.    (95 85 (4 54 71 74 77 84)) 
  325.    (96 174 (15 18 41 46 64 65 66 79 89)) 
  326.    (97 219 (11 37 50 53 66 72 73 81 93 94)) 
  327.    (98 100 (4 24 46 51 63 82)) 
  328.    (99 254 (29 52 53 67 75 80 84 89)) 
  329.    (100 145 (15 20 22 29 34 44 60 87)) 
  330.  ))
  331.  
  332.  
  333. ;**************************************************
  334.  
  335. ;    DISPLAY METHODS
  336.  
  337.  
  338. (defmethod DISPLAY ((graph graph))
  339.   "Display the nodes and edges."
  340.   (format *standard-output* "~%~%GRAPH NODES IN FORMAT INDEX / WEIGHT / COLOR / NEIGHBORS~%")
  341.   (loop for node in (nodes graph)
  342.     do (display node)))
  343.  
  344.  
  345. (defmethod DISPLAY ((node node))
  346.   (format *standard-output* "~%  ~a    ~a   ~a    ~a"
  347.       (index node)
  348.       (weight node)
  349.       (if (color node) (color node) '-)
  350.       (loop for neighbor in (neighbors node)
  351.         collect (index neighbor))))
  352.  
  353.  
  354.  
  355. ;*******************************************************
  356.  
  357. ;    NODE COLORING EVALUATOR
  358.  
  359.  
  360. ;;; The evaluator for Chapter 6 of the Handbook.
  361.  
  362. (defclass NODE-COLORING-EVALUATOR
  363.       (evaluator)
  364.   ((GRAPH :initarg :graph :initform (make-graph-from-specs *graph-specs*)
  365.       :accessor graph)
  366.    (COLORS :initarg :colors :initform '(A B) :accessor colors)
  367.    ))
  368.  
  369.  
  370. ;;; Return the list to be permuted
  371.  
  372. (defmethod LIST-TO-PERMUTE ((evaluator node-coloring-evaluator))
  373.   (copy-list (nodes (graph evaluator))))
  374.  
  375.  
  376. ;;; Color the nodes from the chromosome and add the weight of colored nodes.
  377.  
  378. (defmethod EVALUATE-MEMBER ((evaluator node-coloring-evaluator) population-member)
  379.   (reset-for-evaluation (graph evaluator))
  380.   (loop for node in (chromosome population-member)
  381.     with colors = (colors evaluator)
  382.     do (give-node-first-legal-color node colors))
  383.   (loop for node in (nodes (graph evaluator))
  384.     summing (if (color node) (weight node) 0)))
  385.  
  386.  
  387. (defmethod RESET-FOR-EVALUATION ((graph graph))
  388.   "Reset for evaluation"
  389.   (loop for node in (nodes graph)
  390.     do (setf (color node) nil)))
  391.  
  392.  
  393. (defmethod GIVE-NODE-FIRST-LEGAL-COLOR ((node graph-coloring-node) colors)
  394.   "Assign the node the first color that isn't the color of a neighboring node."
  395.   (loop for color in colors
  396.     with neighbors = (neighbors node)
  397.     when (not (already-colored color neighbors))
  398.     do (return (setf (color node) color))))
  399.  
  400.  
  401. (defun ALREADY-COLORED (color neighbors)
  402.   "Is there a neighbor with this color?"
  403.   (loop for neighbor in neighbors
  404.     thereis (eq color (color neighbor))))
  405.  
  406.  
  407.  
  408.  
  409.